home *** CD-ROM | disk | FTP | other *** search
/ Shareware Gold 2 / Shareware Gold II - Volume 2 Number 1 - Wayzata Technology (7071) (1991).iso / database / pds_base / utilprog.exe / lha / MAILMERG.SRC < prev    next >
Text File  |  1990-03-10  |  10KB  |  148 lines
  1. |2010 DIM YA$(|12),YA%(|12,2),ZS9(|13,1),YT$(|35),YT%(|35,8),YR$(|35)
  2. *23 |2015 DIM YH%(|02,|04),YE%(|02,|04) 'Keep track of first and last Detail record numbers
  3. |2100 BLINKNORMAL%=|28:BLINKINSERT%=|29:BLINK2%=|30 'For CGA or EGA adapter, BLINKNORMAL%=6, BLINKINSERT%=4 and BLINK2%=7. For Monochrome adapter, BLINKNORMAL%=13, BLINKINSERT%=9 and BLINK2%=14.
  4. 2110 CLS:LOCATE 1,19,0:COLOR COLA%(2),COLA%(1)
  5. 2120 PRINT "PDS*BASE Data Base Mail Merge File Program";:COLOR 7,0
  6. |2130 ZPASS=1:ZF$="|15":ZA=|16
  7. 2140 ON ERROR GOTO 2190
  8. 2150 LOCATE 3,19:COLOR COLA%(2),0:PRINT "Reading sort keys from file ";ZF$;:COLOR 7,0::OPEN ZF$ FOR INPUT AS ZQ+1:IF ZPASS=1 THEN INPUT #ZQ+1, ZTDATE$,ZTTIME$:INPUT #ZQ+1, Z5
  9. |2160 IF ZPASS=1 THEN IF Z5<>ZS%(|16,6) THEN BEEP:LOCATE 4,2:COLOR 0,COLA%(4):PRINT "The number of records in the key file doesn't = Number of records in data base";:COLOR 7,0:CLOSE #ZQ+1:FOR X=1 TO 1000:NEXT:GOTO 2210
  10. 2170 IF ZPASS=1 THEN IF ZDATE$(ZA)<>ZTDATE$ OR ZTIME$(ZA)<>ZTTIME$ THEN BEEP:LOCATE 4,7:COLOR 0,COLA%(4):PRINT "Date & Time for the key file doesn't=Date & Time in the data base";:COLOR 7,0:CLOSE #ZQ+1:FOR X=1 TO 1000:NEXT:GOTO 2210
  11. 2180 ON ERROR GOTO 0:GOTO 2220
  12. 2190 RESUME 2200
  13. *39 2200 IF ZPASS=2 THEN 2210 ELSE ZF$=CHR$(ZT%(ZA,1,3)+64)+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2150
  14. *40 2200 IF ZPASS=2 THEN 2210 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2150
  15. *41 2205 RESUME 2210
  16. *42 2210 ON ERROR GOTO 0:CLOSE #ZQ+1:GOTO 2250
  17. *41 2210 LOCATE 5,8:PRINT "The sort key file can not be used - Run the sort program again.":LOCATE 6,20,1:PRINT "Strike any key to end the program . . .":a$=input$(1):GOTO 400
  18. *42 2220 ZZ5=0 'read the sort key file
  19. *42 2230 WHILE NOT EOF(ZQ+1):ZZ5=ZZ5+1:INPUT #ZQ+1, YA%(ZZ5,2):WEND 'read the live record numbers
  20. *42 2240 CLOSE #ZQ+1:IF ZZ5=ZS%(ZA,6) THEN IF ZPASS=1 THEN GOTO 2500 'the number of records in the sort key file may be larger if a master was deleted and re-created in the same dated session
  21. *42 |2250 LOCATE 5,11:COLOR COLA%(2),0:PRINT "The data base must be re-sorted from the '";ZS$(|16,1);"' file.";:COLOR 7,0:Z5=0:ZA=|16
  22. *42 2260 ZJJ=ZS%(ZA,2):IF ZPASS=2 AND ZZ5=ZS%(ZA,6) THEN ZJJ=ZZ5
  23. *42 2270 FOR ZJ=1 TO ZJJ
  24. *42 2280 IF ZZ5=ZS%(ZA,6) AND ZPASS=2 THEN ZR=YA%(ZJ,2) ELSE ZR=ZJ
  25. *42 2290 ZZ=1:GOSUB 610
  26. *42 |2300 IF ZL$<>STRING$(ZSIZE%(|16,|17),32) THEN Z5=Z5+1:YA$(Z5)=|22:YA%(Z5,1)=Z5:YA%(Z5,2)=ZR:LOCATE 6,25:PRINT ZR,ZL$;
  27. *42 2310 NEXT 'ZJ
  28. *42 |2320 ZREPTFLAG=0:IF Z5<> ZS%(|16,6) THEN ZS%(|16,6)=Z5:ZREPTFLAG=1 ' correct records assigned and set flags to correct the housekeeping record on closing the data base.
  29. *42 2330 SOUND 400,1:LOCATE 7,20:COLOR COLA%(2),0:PRINT "There will be a file sort delay.";:COLOR 7,0:T%=INT((80-LEN(YA$(1)))/2)
  30. *42 2340 ZZT$=TIME$:ZT1=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2)))
  31. *42 2350 ZI1=1:ZJ1=Z5:ZP=0
  32. *42 2360 ZI=ZI1:ZJ=ZJ1
  33. *42 2370 IF YA$(YA%(ZI,1))>YA$(YA%(ZJ,1)) THEN SWAP YA%(ZI,1),YA%(ZJ,1):SWAP YA%(ZI,2),YA%(ZJ,2):ZZS%=ABS(ZZS%-1)
  34. *42 2380 ZI=ZI+ZZS%:ZJ=ZJ-(1-ZZS%):IF ZI<ZJ THEN 2370
  35. *42 2390 IF ZI+1<ZJ1 THEN ZP=ZP+1:ZS9(ZP,0)=ZI+1:ZS9(ZP,1)=ZJ1
  36. *42 2400 ZJ1=ZI-1:IF ZI1<ZJ1 THEN 2360
  37. *42 2410 IF ZJ>0 THEN LOCATE 8,T%,0:PRINT YA$(YA%(ZJ,1)); 'remove this warm fuzzy line to speed up sort
  38. *42 2420 IF ZP THEN ZI1=ZS9(ZP,0):ZJ1=ZS9(ZP,1):ZP=ZP-1:GOTO 2360
  39. *42 2430 ZZT$=TIME$:ZT2=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2)))
  40. *42 2440 BEEP:LOCATE 8,1:PRINT SPC(79):LOCATE 8,20:COLOR COLA%(2),0:ZT3=ZT2-ZT1:IF ZT3 < 120 THEN PRINT "Elapsed time=";ZT3;" seconds" ELSE PRINT "Elapsed time =";INT(ZT3/60);" minutes ";INT( ( (ZT3/60)-INT(ZT3/60) ) * 60 );" seconds"
  41. *42 |2450 COLOR 7,0:ZPASS=1:ZF$="|15"
  42. *42 2460 OPEN ZF$ FOR OUTPUT AS ZQ+1:IF ZPASS=1 THEN WRITE #ZQ+1,ZDATE$(ZA);ZTIME$(ZA):PRINT #ZQ+1,Z5
  43. *42 2470 FOR ZI=1 TO Z5:PRINT #ZQ+1,YA%(ZI,2):NEXT 'ZI
  44. *42 2480 CLOSE #ZQ+1
  45. *39 2490 IF ZPASS=2 THEN 2500 ELSE ZF$=CHR$(ZT%(ZA,1,3)+64)+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2460
  46. *40 2490 IF ZPASS=2 THEN 2500 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2460
  47. 2500 '****** Ask For Output File Name ******
  48. 2510 LOCATE 10,10,0:COLOR COLA%(2),0:PRINT "Enter Comma Delimited Output File Name ";:FLDPOSHORIZ%=POS(0):FLDPOSVERT%=CSRLIN
  49. 2520 GOSUB 5000
  50. 2530 IF ESCFLAG%=1 OR F$=STRING$(20,32) THEN GOTO 400
  51. 2540 ON ERROR GOTO 2590:OPEN F$ FOR INPUT AS #ZQ+1:CLOSE ZQ+1
  52. 2550 ON ERROR GOTO 0:LOCATE 24,5,0:COLOR 15,0:BEEP:PRINT "File "+F$+" already exists. Do you wish to replace it ? ";:COLOR 0,COLA%(3):PRINT "N";:LOCATE ,POS(0)-1,1
  53. 2560 A$="":WHILE A$="":A$=INKEY$:WEND:IF ASC(A$)=13 THEN A$="N"
  54. 2570 PRINT A$;:COLOR 7,0:FOR J=1 TO 500:NEXT:LOCATE 24,1:PRINT SPC(79)
  55. 2580 IF A$<>"Y" AND A$<>"y" THEN GOTO 2500 ELSE GOTO 2600
  56. 2590 RESUME 2600
  57. 2600 OPEN F$ FOR OUTPUT AS #ZQ+1
  58. |3110 FOR ZI=1 TO |35:FOR ZJ=1 TO 8:READ YT%(ZI,ZJ):NEXT:READ HEADER$(ZI),TRAILER$(ZI):NEXT ZI
  59. 3120 ' YT%(X,Y) X=Field on report, Y=1 is file number, 2=field in that file, 3=lead to file, 4=lead to field
  60. 3130 ' 5=Detail fld action code (1=1st Detail, 2=last, 3=all), 6=Associated Master if this is a Detail
  61. 3140 ' 7=Which Detail set for this Detail's Master, 8=1 If field starts new row
  62. *44
  63. 3300 YL$="":ZA=0
  64. 3310 LOCATE 12,18,0:COLOR COLA%(2),COLB%(1):PRINT "Writing to disk file ";F$;:COLOR 7,0
  65. 3340 FOR ZI=1 TO Z5 'loop for each record in the sort file
  66. 3350 YF=0:MOREDETAIL%=0:YJ=1
  67. |3360 FOR ZJ=YJ TO |35 'loop for each field in the Label
  68. 3370 IF ZJ=1 THEN ZZ=1:ZA=YT%(1,1):ZR=YA%(ZI,2):GOSUB 610:GOSUB 4000:GOTO 3420 'read the record for the first field
  69. *47 3380 IF ZS%(YT%(ZJ,1),1)=2 GOTO 3440
  70. 3390 IF ZA=YT%(ZJ,1) THEN GOSUB 4000:GOTO 3570 'additional field in the same master
  71. 3400 IF ZA<>YT%(ZJ,1) AND ZS%(YT%(ZJ,1),1)=1 AND YR$(ZJ)=STRING$(YT%(ZJ,4),32) THEN GOTO 3580 'skip the new field if the field leading to it was blank
  72. 3410 IF ZA<>YT%(ZJ,1) AND ZS%(YT%(ZJ,1),1)=1 THEN ZA=YT%(ZJ,1):ZR$=YR$(ZJ):GOSUB 500:GOSUB 600:LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA) 'field in a different master
  73. *47 3420 IF ZS%(ZA,4)>0 THEN FOR ZK=1 TO ZS%(ZA,4):YH%(ZA,ZK)=ZH(ZK):YE%(ZA,ZK)=ZE(ZK):NEXT 'ZK  store the chain head and ends for this master record
  74. *48 3420 REM continuation line - do not remove
  75. *47 3430 GOTO 3540
  76. *47 3440 'handle the detail record DO NOT remove this REM line
  77. *47 3450 IF YT%(ZJ,1) = YT%(ZJ-1,1) THEN GOTO 3540
  78. *47 3460 ZR=0:ZA=YT%(ZJ,1)
  79. *47 3470 IF YF>0 THEN ZR=YF:GOTO 3500
  80. *47 3480 IF YT%(ZJ,5)<>2 THEN ZR=YH%(YT%(ZJ,6),YT%(ZJ,7))
  81. *47 3490 IF YT%(ZJ,5)=2 THEN ZR=YE%(YT%(ZJ,6),YT%(ZJ,7))
  82. *47 3500 IF ZR>0 THEN ZZ=1:GOSUB 610 'read the 1st, last or next detail record
  83. *47 3510 IF ZR=0 GOTO 3580
  84. *47 3520 IF YT%(ZJ,5)=3 AND ZF>0 THEN MOREDETAIL%=1
  85. *47 3530 IF MOREDETAIL%=1 THEN IF ZF>0 THEN YJ=ZJ:YF=ZF ELSE YF=0 'set up to read additional details
  86. *47 3540 GOSUB 4000
  87. |3550 FOR Z1=1 TO |35:IF ZA=YT%(Z1,3) THEN YR$(Z1)=Y$(YT%(Z1,4),ZA) 'set up future field search value
  88. 3560 NEXT 'Z1
  89. 3570 NEXT 'ZJ
  90. 3580 PRINT #ZQ+1,  'end of record
  91. 3600 IF YF>0 THEN GOTO 3360 'repeat for additional Details
  92. 3610 NEXT 'ZI
  93. 3620 CLOSE ZQ+1
  94. 3640 'all done"
  95. 3650 GOTO 400
  96. 4000 '***** Trim and Print Subroutine *****
  97. 4040 SKIP%=0:FLDLEN%=LEN(Y$(YT%(ZJ,2),ZA)):IF Y$(YT%(ZJ,2),ZA)=STRING$(FLDLEN%,32) THEN SKIP%=1:GOTO 4070 ELSE IF RIGHT$(Y$(YT%(ZJ,2),ZA),1)<>" " THEN GOTO 4070 ' field is full
  98. 4050 FOR K=FLDLEN% TO 1 STEP -1:IF MID$(Y$(YT%(ZJ,2),ZA),K,1)<>" " THEN FLDLEN%=K:K=1
  99. 4060 NEXT 'K
  100. 4070 IF ZJ>1 THEN PRINT #ZQ+1, ",";
  101. 4080 IF SKIP%=1 THEN PRINT #ZQ+1, CHR$(34)+CHR$(34);:RETURN 'two quote marks for empty field
  102. 4090 PRINT #ZQ+1, CHR$(34)+LEFT$(Y$(YT%(ZJ,2),ZA),FLDLEN%)+CHR$(34);
  103. 4100 RETURN
  104. 5000 'Subroutine to input File Name
  105. 5040    EFLAG%=1:ESCFLAG%=0:CFLAG%=0:ZENDSAVE%=0:INSERT%=0
  106. 5050    WHILE EFLAG%=1 'loop on this field until EFLAG% set to zero
  107. 5060       F$=STRING$(20,32):LOCATE FLDPOSVERT%,FLDPOSHORIZ%,0:COLOR 0,COLA%(3):PRINT F$:COLOR 7,0:LOCATE FLDPOSVERT%,FLDPOSHORIZ%,1:Z2=20
  108. 5070       FOR ZJ=1 TO Z2
  109. 5080          YC$="":WHILE YC$="":YC$=INKEY$:WEND:POSX%=CSRLIN:POSY%=POS(0) 'strobe keyboard for next character
  110. 5090          IF CFLAG%=1 THEN LOCATE 25,1,0:PRINT SPC(79):LOCATE POSX%,POSY%,1:CFLAG%=0
  111. 5100          IF LEN(YC$)=2 THEN YC%=ASC(RIGHT$(YC$,1)):GOSUB 5600:GOTO 5190
  112. 5110          YC%=ASC(YC$)
  113. 5120          IF YC%=27 THEN ZJ=Z2:ESCFLAG%=1:GOTO 5190
  114. 5130          IF YC%=8 THEN GOSUB 5500:GOTO 5080
  115. 5140          IF YC%=13 THEN ZJ=Z2:GOTO 5190
  116. 5150          POSY%=POS(0):GOSUB 5800:IF CFLAG%=1 THEN LOCATE POSX%,POSY%,1:GOTO 5080
  117. 5160          IF INSERT%=1 THEN GOSUB 6200 
  118. 5170          COLOR 0,COLA%(3):PRINT YC$;:COLOR 7,0:MID$(F$,ZJ,1)=YC$
  119. 5190       NEXT 'ZJ
  120. 5200       LOCATE ,,,BLINKNORMAL%,BLINK2%:INSERT%=0:IF ZI=1 THEN IF YC%=13 AND F$=STRING$(Z2,32) THEN RETURN 'finished
  121. 5210       IF ESCFLAG%=1 THEN RETURN 'abort from this record
  122. 5220       EFLAG%=0
  123. 5250    WEND 'EFLAG%
  124. 5330 RETURN
  125. 5500 'Subroutine for backspace
  126. 5520 IF ZJ=1 THEN RETURN
  127. 5530 IF FLDTYPE%=4 AND EFLAG%=0 THEN IF ZJ=3 OR ZJ=7 THEN LOCATE ,POS(0)-2:ZJ=ZJ-2:RETURN 'skip spaces on Date field
  128. 5540 LOCATE ,POS(0)-1,1:COLOR 0,COLA%(3):PRINT " ";:COLOR 7,0:LOCATE ,POS(0)-1,1:MID$(F$,ZJ-1,1)=" ":ZJ=ZJ-1
  129. 5550 RETURN
  130. 5600 'Extended code key pressed
  131. 5640 IF YC%=75 THEN ZJ=ZJ-1:IF ZJ>0 THEN ZJ=ZJ-1:LOCATE ,POS(0)-1:RETURN 'left arrow
  132. 5650 IF YC%=77 AND ZJ<Z2 THEN LOCATE ,POS(0)+1:RETURN 'right arrow
  133. 5710 IF YC%=82 THEN ZJ=ZJ-1:IF INSERT%=0 AND ZJ<Z2 THEN INSERT%=1:LOCATE ,,,BLINKINSERT%,BLINK2%:RETURN ELSE INSERT%=0:LOCATE ,,,BLINKNORMAL%,BLINK2%:RETURN ' insert key
  134. 5720 IF YC%=83 THEN IF ZJ<Z2 THEN FLD$=MID$(F$,ZJ+1)+" " ELSE FLD$=" " 'delete key
  135. 5730 IF YC%=83 THEN COLOR 0,COLA%(3):LOCATE ,,0:PRINT FLD$:COLOR 7,0:LOCATE FLDPOSVERT%,POSY%,1:MID$(F$,ZJ)=FLD$:ZJ=ZJ-1:RETURN 'delete key
  136. 5740 SOUND 400,1:RETURN 'key not used
  137. 5800 'Character type field
  138. 5810 IF YC%>96 AND YC%<123 THEN YC%=YC%-32:YC$=CHR$(YC%):RETURN ELSE IF YC%>44 OR YC%<91 THEN RETURN
  139. 5820 SOUND 400,1:CFLAG%=1
  140. 5830 LOCATE 25,31,0:COLOR 15,0:PRINT "Illegal key stroke";:COLOR 7,0
  141. 5840 RETURN
  142. 6200 'Handle Inserted Character
  143. 6210 IF ZJ=Z2 THEN RETURN 'no insert if at end of field
  144. 6220 FLD$=MID$(F$,ZJ,Z2-ZJ)
  145. 6230 MID$(F$,ZJ+1,Z2-ZJ-1)=FLD$:COLOR 0,COLA%(3):LOCATE ,POSY%+1,0:PRINT FLD$;:COLOR 7,0:LOCATE ,POSY%,1
  146. 6240 RETURN
  147. *31 Copyright 1987 by PRO DEV Software
  148.